perm filename MIXSCR.F4[SCR,LCS]5 blob sn#367631 filedate 1978-07-11 generic text, type T, neo UTF8
00100	C***** MIXES AND LINKS FILES PUT OUT BY 'SCORE' *******
00200	C***** ALL FILES MUST HAVE THE .SCR EXTENSION *****
00300	C***** LOAD WITH RENAM.FAI 
00400	C***** USE 'R LOADER'.  INCLUDE '/LLIB40.OLD[1,3]'.  OTHERWISE THERE
00500	C	WILL BE READ ERRORS DUE TO BUGS IN CURRENT LIB40 3/77 *******
00600	
00700		COMMON /VV/Q(19),R(19),KL,N1,N2,N3,J,K,L,M,P1,PX,A,B,C,D,IBL
00800		COMMON /LNK/ NK,NZ(10),IP
00900		DATA IBL/'     '/
01000		TYPE 24
01100		NK=0
01200		LX=0
01300		ACCEPT 2,K,IP
01400		IF(K.EQ.'L')LX=-1
01500	200	TYPE 20
01600		ACCEPT 2,N1
01700		IF(N1.EQ.IBL)GO TO 200
01800		IF(FINDIT(N1))CALL NOTFND(N1)
01900	C  DO A LOOKUP FIRST OF ALL
02000	CC	CALL RENAMX(N1,'SCR','$$$$1','DAT')
02100	201	TYPE 22
02200		ACCEPT 2,N2
02300		IF(N2.EQ.IBL.OR.N2.EQ.N1)GO TO 201
02400		IF(FINDIT(N2))CALL NOTFND(N2)
02500		IF(LX.EQ.0)GO TO 202
02600	1000	TYPE 41
02700		ACCEPT 2,K
02800		IF(K.EQ.IBL)GO TO 202
02900	C TAKES UP TO 2+10 FILES.
03000		NK=NK+1
03100		NZ(NK)=K
03200		IF(NK.LT.10)GO TO 1000
03300		
03400	202	TYPE 23
03500		ACCEPT 2,N3
03600		IF(N3.EQ.IBL)GO TO 202
03700		CALL OFILE(1,N3)
03800		TYPE 300
03900	300	FORMAT(' ****** CAUTION ******'/
04000		1' ****** NEVER STOP THIS PROGRAM WHILE IT IS WORKING ******'/)
04100		CALL RENAMX(N1,'SCR','$$$$1','DAT')
04200		CALL RENAMX(N2,'SCR','$$$$2','DAT')
04300		CALL IFILE(21,'$$$$1')
04400		CALL IFILE(22,'$$$$2')
04500		TYPE 25
04600		IF(LX.EQ.0)GO TO 25
04700		CALL LINK
04800		GO TO 204
04900	25	FORMAT(/' WORKING'/)
05000		DO 1 K=1,3
05100		READ(21,2)Q
05200		WRITE(1,2)Q
05300	1	READ(22,2)Q
05400	C READS FIRST 3 LINES
05500		
05600		CALL CHECK(N,Q,P1,21)
05700		CALL CHECK(M,R,PX,22)
05800	CATCHES INSERTED LINES.
05900	6	IF(PX.LT.P1)GO TO 5
06000		CALL RDWRT(N,P1,Q,21)
06100		IF(KL)10,6,6
06200	
06300	5	CALL RDWRT(M,PX,R,22)
06400		IF(KL.EQ.0)GO TO 6
06500	
06600	11	PX=10000
06700		GO TO 13
06800	10	P1=10000
06900	13	IF(P1.NE.10000.OR.M.NE.N)GO TO 6
07000	CC13	IF(P1.NE.10000.AND.M.NE.N)GO TO 6
07100	12	WRITE(1,7)
07200		REWIND 21
07300		REWIND 22
07400		CALL RENAMX('$$$$1','DAT',N1,'SCR')
07500		CALL RENAMX('$$$$2','DAT',N2,'SCR')
07600	204	END FILE 1
07700		CALL RENAM(N3,'DAT',N3,'SCR')
07800		TYPE 203,N3
07900		CALL EXIT
08000	203	FORMAT(/' ******  MIX FILE NAME = ',A5,'.SCR')
08100	2	FORMAT(19A5)
08200	7	FORMAT(' FINISH;')
08300	24	FORMAT(' MIXES OR LINKS SCORE LISTS.'/
08400		1' USES ".SCR" EXTENSIONS ONLY!!! '/
08500		1' BE SURE ALL HIGHER PARAMS PRINT EACH TIME.'
08600		1//' L = LINK, <CR> = MIX  '$)
08700	41	FORMAT(' TYPE NEXT FILE NAME OR <CR>  '$)
08800	20	FORMAT(' TYPE FILE 1 (WITHOUT EXT.)   '$)
08900	22	FORMAT(/' TYPE FILE 2  '$)
09000	23	FORMAT(/' TYPE OUTPUT NAME  '$)
09100		END
09200	
09300		SUBROUTINE CHECK(N,Q,P1,J)
09400		COMMON /VV/QQ(19),RR(19),KL,N1,N2,N3,JJ,KK,L,M,P,PX,LL,K,IBL
09500		DIMENSION Q(19),AA(50)
09550		DATA J1/4/,J2/9/,J3/18/
09575	C  J1,J2,J3 ARE POINTERS TO POS. OF DOTS IN P1,P2
09600		KL=0
09700	33	READ(J,30,END=100)L,N,K,Q,AA
09800		IF(Q(J1).NE.' ')GO TO 32
09900		IF(Q(J2).NE.'.')GO TO 32
10000		IF(Q(J3).EQ.'.')GO TO 31
10100	CATCHES INSERTED LINES.
10200	32	REREAD 44,L,N,Q
10300		IF(N.EQ.'FINIS')KL=-1
10400		CALL SHORT(Q,N)
10500	CC	TYPE 44,L,N,(Q(LL),LL=1,K)
10600		IF(KL)RETURN
10700	CC	WRITE(1,44)L,N,(Q(LL),LL=1,K)
10800		GO TO 33
10900	100	PAUSE 'DIED IN SUBR CHECK'
11000	31	REREAD 4,L,N,P1
11100		REREAD 44,L,N,Q
11200	30	FORMAT(72A1)
11300	4	FORMAT(A1,A5,F)
11400	44	FORMAT(A1,20A5)
11500		END
11600	
11700		SUBROUTINE SHORT(Q,N)
11800		COMMON /VV/QQ(19),RR(19),KL,N1,N2,N3,JJ,KK,L,M,P,PX,LL,K,A,B,IBL
11900		COMMON /LNK/ NK,NZ(10),IP
12000		DIMENSION Q(1)
12200		DO 1 K=19,1,-1
12300	1	IF(Q(K).NE.' ')GO TO 2
12400	2	IF(IP.NE.IBL)TYPE 44,L,N,(Q(LL),LL=1,K)
12500		IF(KL)RETURN
12600		WRITE(1,44)L,N,(Q(LL),LL=1,K)
12700	44	FORMAT(A1,20A5)
12800		END
12900	
13000		SUBROUTINE RDWRT(I,P,R,J)
13100		COMMON /VV/Q(19),RR(19),KL,N1,N2,N3,JJ,KK,L,M,P1,PX,LL,K,IBL
13200		DIMENSION R(19)
13300		KL=0
13400		CALL SHORT(R,I)
13500	CC	WRITE(1,44)L,I,(R(N),N=1,K)
13600	CC	TYPE 44,L,I,(R(N),N=1,K)
13700	1	READ (J,44,END=100)L,I,R
13800	CXX	REREAD 44,L,I,R
13900		CALL SHORT(R,I)
14000	CC	WRITE(1,44)L,I,(R(N),N=1,K)
14100	CC	TYPE 44,L,I,(R(N),N=1,K)
14200		IF(I.NE.'PRINT')GO TO 1 
14300	2	CALL CHECK(I,R,P,J)
14400		RETURN
14500	44	FORMAT(A1,20A5)
14600	100	PAUSE 'DIED IN SUBR RDWRT'
14700		END
14800	
14900		SUBROUTINE LINK
15000		COMMON /VV/Q(19),RR(19),KL,N1,N2,N3,JJ,KK,L,M,P1,PX,LL,K,IBL
15100		COMMON /LNK/ NK,NZ(10),IP
15200	44	FORMAT(A1,20A5)
15300		KL=0
15400		JJ=0
15500		J=21
15600	1	READ(J,44)L,LL,Q
15700		IF(LL.EQ.'FINIS')GO TO 2
15800	4	CALL SHORT(Q,LL)
15900		IF(JJ.GT.NK)RETURN
16000		GO TO 1
16100	2	IF(J.NE.21)GO TO 3
16200		REWIND 21
16300		CALL RENAMX('$$$$1','DAT',N1,'SCR')
16400		J=J+1
16500		GO TO 1
16600	3	REWIND 22
16700		IF(JJ.NE.0)GO TO 6
16800		CALL RENAMX('$$$$2','DAT',N2,'SCR')
16900		GO TO 5
17000	6	CALL RENAMX('$$$$2','DAT',NZ(JJ),'SCR')
17100	5	JJ=JJ+1
17200		IF(JJ.GT.NK)GO TO 4
17300		CALL RENAMX(NZ(JJ),'SCR','$$$$2','DAT')
17400		CALL IFILE(22,'$$$$2')
17500		GO TO 1
17600		END
17700	
17800		SUBROUTINE RENAMX(J,K,L,M)
17900		CALL RENAM(J,K,L,M)
18000		TYPE 1,J,K,L,M
18100	1	FORMAT(' (RENAME -- ',A5,'.',A3,' CHANGED TO -- ',A5,'.',A3,')')
18200		END
18300	 
18400		SUBROUTINE NOTFND(NM)
18500		TYPE 1,NM
18600		CALL EXIT
18700	1	FORMAT(' ******* FILE ',A5,'.SCR   NOT FOUND *****')
18800		END